home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_Tix.idb / usr / freeware / lib / tix4.1 / fs.tcl.z / fs.tcl
Encoding:
Text File  |  1999-01-26  |  10.8 KB  |  626 lines
  1. # tixAssert --
  2. #
  3. #    Debugging routine. Evaluates the test script in the context of the
  4. #    caller. The test script is responsible for generating the error.
  5. #    
  6. proc tixAssert {script} {
  7.     uplevel $script
  8. }
  9.  
  10. proc tixAssertNorm {path} {
  11.     if ![tixFSIsNorm $path] {
  12.     error "\"$path\" is not a normalized path"
  13.     }
  14. }
  15.  
  16. proc tixAssertVPath {vpath} {
  17.     if ![tixFSIsVPath $vpath] {
  18.     error "\"$vpath\" is not a VPATH"
  19.     }
  20. }
  21.  
  22. # tixFSAbsPath --
  23. #
  24. #    Converts $path into an normalized absolute path
  25. #
  26. proc tixFSAbsPath {path} {
  27.     return [lindex [tixFSNorm [tixFSVPWD] $path] 0]
  28. }
  29.  
  30. # tixFSVPWD --
  31. #
  32. #    Returns the VPATH of the current directory.
  33. #
  34. proc tixFSVPWD {} {
  35.     return [tixFSVPath [tixFSPWD]]
  36. }
  37.  
  38. if {![info exists tcl_platform] || $tcl_platform(platform) == "unix"} {
  39.  
  40. # tixFSPWD --
  41. #
  42. #    Return the current directory
  43. #
  44. proc tixFSPWD {} {
  45.     return [pwd]
  46. }
  47.  
  48. # tixFSDisplayName --
  49. #
  50. #    Returns the name of a normalized path which is usually displayed by
  51. #    the OS
  52. #
  53. proc tixFSDisplayName {normpath} {
  54.     tixAssert {
  55.     tixAssertNorm $normpath
  56.     }
  57.     return $normpath
  58. }
  59.  
  60. proc tixFSIsAbsPath {path} {
  61.     return [tixStrEq [string index $path 0] /]
  62. }
  63.  
  64. # tixFSIsNorm_os --
  65. #
  66. #    Returns true iff this pathname is normalized, in the OS native name
  67. #    format
  68. #
  69. proc tixFSIsNorm_os {path} {
  70.     return [tixFSIsNorm $path]
  71. }
  72.  
  73. proc tixFSIsNorm {path} {
  74.     if [tixStrEq $path /] {
  75.     return 1
  76.     }
  77.  
  78.     # relative path
  79.     #
  80.     if ![regexp {^/} $path] {
  81.     return 0
  82.     }
  83.  
  84.     if [regexp {/[.]$} $path] {
  85.     return 0
  86.     }
  87.     if [regexp {/[.][.]$} $path] {
  88.     return 0
  89.     }
  90.     if [regexp {/[.]/} $path] {
  91.     return 0
  92.     }
  93.     if [regexp {/[.][.]/} $path] {
  94.     return 0
  95.     }
  96.     if [tixStrEq $path .] {
  97.     return 0
  98.     }
  99.     if [tixStrEq $path ..] {
  100.     return 0
  101.     }
  102.  
  103.     # Tilde
  104.     #
  105.     if [regexp {^~} $path] {
  106.     return 0
  107.     }
  108.  
  109.     # Double slashes
  110.     #
  111.     if [regexp {//} $path] {
  112.     return 0
  113.     }
  114.  
  115.     # Trailing slashes
  116.     #
  117.     if [regexp {/$} $path] {
  118.     return 0
  119.     }
  120.  
  121.     return 1
  122. }
  123.  
  124. # tixFSIsValid --
  125. #
  126. #    Checks whether a native pathname contains invalid characters.
  127. #
  128. proc tixFSIsValid {path} {
  129.     return 1
  130. }
  131.  
  132. proc tixFSIsVPath {vpath} {
  133.     return [tixFSIsNorm $vpath]
  134. }
  135.  
  136. # tixFSVPath --
  137. #
  138. #    Converts a native pathname to its VPATH
  139. #
  140. proc tixFSVPath {path} {
  141.     tixAssert {
  142.     tixAssertNorm $path
  143.     }
  144.     return $path
  145. }
  146.  
  147. # tixFSPath --
  148. #
  149. #    Converts a vpath to a native pathname
  150. proc tixFSPath {vpath} {
  151.     tixAssert {
  152.     tixAssertVPath $vpath
  153.     }
  154.     return $vpath
  155. }
  156.  
  157. # tixFSTildeSubst -- [Unix only]
  158. #
  159. #    Substitutes any leading tilde characters if possible. No error is
  160. #    generated if the user doesn't exist.
  161. #
  162. proc tixFSTildeSubst {text} {
  163.     if [tixStrEq [string index $text 0] ~] {
  164.     # The following will report if the user doesn't exist
  165.     if [catch {
  166.         file isdir $text
  167.     }] {
  168.         return ./$text
  169.     }
  170.     return [tixFile tilde $text]
  171.     } else {
  172.     return $text
  173.     }
  174. }
  175.  
  176. # tixFSNorm --
  177. #
  178. #    Interprets the user's input and return file information about this
  179. #    input.
  180. #
  181. # Arguments:
  182. #    See documentation (docs/Files.txt)
  183. #
  184. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  185.     tixAssert {
  186.     tixAssertVPath $context
  187.     }
  188.  
  189.     if ![tixStrEq $errorMsgVar ""] {
  190.     upvar $errorMsgVar errorMsg
  191.     }
  192.     if ![tixStrEq $flagsVar ""] {
  193.     upvar $flagsVar flags
  194.     }
  195.  
  196.     set hasDirSuffix [regexp {/$} $text]
  197.     set text [tixFSTildeSubst $text]
  198.     set text [_tixJoin $context $text]
  199.  
  200.     if {$hasDirSuffix || [file isdir $text]} {
  201.     set dir $text
  202.     set tail $defFile
  203.     } else {
  204.     set dir [file dirname $text]
  205.     set tail [file tail $text]
  206.     }
  207.  
  208.     set norm $dir/$tail
  209.     regsub -all /+ $norm / norm
  210.     if ![tixStrEq $norm /] {
  211.     regsub {/$} $norm "" norm
  212.     }
  213.  
  214.     if ![info exists flag(noPattern)] {
  215.     set isPat 0
  216.     foreach char [split $tail ""] {
  217.         if {$char == "*" || $char == "?"} {
  218.         set isPat 1
  219.         break
  220.         }
  221.     }
  222.     if {$isPat} {
  223.         return [list $norm $dir "" $tail]
  224.     }
  225.     }
  226.  
  227.     return [list $norm $dir $tail ""]
  228. }
  229.  
  230. # _tixJoin -- [Internal]
  231. # 
  232. #    Joins two native pathnames.
  233. #
  234. proc _tixJoin {p1 p2} {
  235.     if [tixStrEq [string index $p2 0] /] {
  236.     return [_tixNormalize $p2]
  237.     } else {
  238.     return [_tixNormalize $p1/$p2]
  239.     }
  240. }
  241.  
  242. # tixFSNormDir --
  243. #
  244. #    Normalizes an absolute path.
  245. #
  246. proc tixFSNormDir {dir} {
  247.     set dir [tixFile tilde $dir]
  248.     if ![tixStrEq [string index $dir 0] /] {
  249.     error "\"$dir\" must be an absolute pathname"
  250.     }
  251.     if ![file isdir $dir] {
  252.     error "\"$dir\" is not a directory"
  253.     }
  254.     return [_tixNormalize $dir]
  255. }
  256.  
  257. # _tixNormalize --
  258. #
  259. #    Normalizes an absolute pathname.
  260. #
  261. #     $dir must be an absolute pathname
  262. #
  263. proc _tixNormalize {path} {
  264.     tixAssert {
  265.     if ![tixStrEq [string index $path 0] /] {
  266.         error "\"$path\" must be an absolute pathname"
  267.     }
  268.     }
  269.  
  270.     # Don't be fooled: $path doesn't need to be a directory. The following
  271.     # code just makes it easy to get rid of trailing . and ..
  272.     #
  273.     set path $path/
  274.     regsub -all /+ $path / path
  275.     while 1 {
  276.     if ![regsub {/\./} $path "/" path] break
  277.     }
  278.     while 1 {
  279.     if ![regsub {/\.$} $path "" path] break
  280.     }
  281.  
  282.     while 1 {
  283.     if ![regsub {/[^/]+/\.\./} $path "/" path] break
  284.     while 1 {
  285.         if ![regsub {^/\.\./} $path "/" path] break
  286.     }
  287.     }
  288.     while 1 {
  289.     if ![regsub {^/\.\./} $path "/" path] break
  290.     }
  291.  
  292.     regsub {/$} $path "" path
  293.     if [tixStrEq $path ""] {
  294.     return /
  295.     } else {
  296.     return $path
  297.     }
  298. }
  299.  
  300. # tixFSCreateDirs
  301. #
  302. #
  303. # 
  304. proc tixFSCreateDirs {path} {
  305.     tixAssert {
  306.     error "Procedure tixFSCreateDirs not implemented on all platforms"
  307.     }
  308.     if [tixStrEq $path /] {
  309.     return 1
  310.     }
  311.     if [file exists $path] {
  312.     return 1
  313.     }
  314.     if ![tixFSCreateDirs [file dirname $path]] {
  315.     return 0
  316.     }
  317.     if [catch {exec mkdir $path}] {
  318.     return 0
  319.     }
  320.     return 1
  321. }
  322.  
  323. } else {
  324.  
  325. #-Win--------------------------------------------------------------------
  326.  
  327. # (Win) tixFSPWD --
  328. #
  329. #    Return the current directory
  330. #
  331. proc tixFSPWD {} {
  332.     set p [pwd]
  333.     regsub -all / $p \\ p
  334.     return $p
  335. }
  336. # Win
  337. #
  338. proc tixFSIsNorm {path} {
  339.  
  340.     # Drive root directory
  341.     #
  342.     if [regexp {^[A-z]:$} $path] {
  343.     return 1
  344.     }
  345.  
  346.     # If it is not a drive root directory, it must
  347.     # have a leading [drive letter:]\\[non empty string]
  348.     if ![regexp {^[A-z]:\\.} $path] {
  349.     return 0
  350.     }
  351.  
  352.     # relative path
  353.     #
  354.     if [regexp {\\[.]$} $path] {
  355.     return 0
  356.     }
  357.     if [regexp {\\[.][.]$} $path] {
  358.     return 0
  359.     }
  360.     if [regexp {\\[.]\\} $path] {
  361.     return 0
  362.     }
  363.     if [regexp {\\[.][.]\\} $path] {
  364.     return 0
  365.     }
  366.     if [tixStrEq $path .] {
  367.     return 0
  368.     }
  369.     if [tixStrEq $path ..] {
  370.     return 0
  371.     }
  372.  
  373.     # Double slashes
  374.     #
  375.     if [regexp {\\\\} $path] {
  376.     return 0
  377.     }
  378.  
  379.     # Trailing slashes
  380.     #
  381.     if [regexp {[\\]$} $path] {
  382.     return 0
  383.     }
  384.  
  385.     return 1
  386. }
  387.  
  388. # (Win) tixFSNorm --
  389. #
  390. #    Interprets the user's input and return file information about this
  391. #    input.
  392. #
  393. # Arguments:
  394. #    See documentation (docs/Files.txt)
  395. #
  396. proc tixFSNorm {context text {defFile ""} {flagsVar ""} {errorMsgVar ""}} {
  397.     tixAssert {
  398.     tixAssertVPath $context
  399.     }
  400.  
  401.     if ![tixStrEq $errorMsgVar ""] {
  402.     upvar $errorMsgVar errorMsg
  403.     }
  404.     if ![tixStrEq $flagsVar ""] {
  405.     upvar $flagsVar flags
  406.     }
  407.  
  408.     set isDir [regexp {[\\]$} $text]
  409.     set text [_tixJoin $context $text]
  410.     set path [tixFSPath $text]
  411.  
  412.     if {$isDir || [file isdir $path]} {
  413.     set vpath $text
  414.     set tail $defFile
  415.     } else {
  416.     set list [split $text \\]
  417.     set tail [lindex $list end]
  418.     set len [string length $tail]
  419.     set vpath [string range $text 0 [expr [string len $text]-$len-1]]
  420.     regsub {[\\]$} $vpath "" vpath
  421.     }
  422.  
  423.     set path [tixFSPath $vpath]
  424.  
  425.     if ![info exists flag(noPattern)] {
  426.     set isPat 0
  427.     foreach char [split $tail ""] {
  428.         if {$char == "*" || $char == "?"} {
  429.         set isPat 1
  430.         break
  431.         }
  432.     }
  433.     if {$isPat} {
  434.         return [list $path $vpath "" $tail]
  435.     }
  436.     }
  437.  
  438.     return [list $path $vpath $tail ""]
  439. }
  440.  
  441. # Win
  442. #
  443. # _tixJoin -- [internal]
  444. #
  445. #    Joins a pathname to a VPATH
  446. #
  447. proc _tixJoin {vp1 p2} {
  448.     if [tixFSIsAbsPath $p2] {
  449.     return [tixFSVPath [_tixNormalize $p2]]
  450.     } else {
  451.     return [tixFSVPath [_tixNormalize [tixFSPath $vp1]\\$p2]]
  452.     }
  453. }
  454.  
  455. # (Win) tixFSIsAbsPath
  456. #
  457. #    The Tcl "file pathtype" is buggy. E.g. C:\.\..\. is absolute, but
  458. #    "file pathtype" thinks that it isn't
  459. #
  460.  
  461. proc tixFSIsAbsPath {path} {
  462.     return [regexp {^[A-z]:\\} $path]
  463. }
  464.  
  465. # (Win) tixFSIsNorm_os
  466. #
  467. #    Returns true iff this pathname is normalized, in the OS native name
  468. #    format
  469. #
  470. proc tixFSIsNorm_os {path} {
  471.     if [regexp {^[A-z]:[\\]$} $path] {
  472.     return 1
  473.     }
  474.     if [regexp {^[A-z]:$} $path] {
  475.     return 0
  476.     }
  477.  
  478.     return [tixFSIsNorm $path]
  479.  
  480. }
  481.  
  482. # Win
  483. #
  484. # _tixNormalize --
  485. #
  486. #    Normalizes an absolute pathname.
  487. #
  488. #     $dir must be an absolute native pathname
  489. #
  490. proc _tixNormalize {abpath} {
  491.     tixAssert {
  492.     if ![tixFSIsAbsPath $abpath] {
  493.         error "\"$abpath\" must be an absolute pathname"
  494.     }
  495.     }
  496.  
  497.     if ![regexp {^[A-z]:} $abpath drive] {
  498.     tixPanic "\"$abpath\" does not contain a drive letter"
  499.     }
  500.     set drive [string toupper $drive]
  501.  
  502.     regsub {^[A-z]:} $abpath "" path
  503.  
  504.     # Don't be fooled: $path doesn't need to be a directory. The following
  505.     # code "set path $path\\" just makes it easy to get rid of trailing
  506.     # . and ..
  507.     #
  508.     set path $path\\
  509.     regsub -all {[\\]+} $path \\ path
  510.     while 1 {
  511.     if ![regsub {\\[.]\\} $path "\\" path] break
  512.     }
  513.     while 1 {
  514.     if ![regsub {\\[.]$} $path "" path] break
  515.     }
  516.  
  517.     while 1 {
  518.     if ![regsub {\\[^\\]+\\[.][.]\\} $path "\\" path] break
  519.     while 1 {
  520.         if ![regsub {^\\[.][.]\\} $path "\\" path] break
  521.     }
  522.     }
  523.     while 1 {
  524.     if ![regsub {^\\[.][.]\\} $path "\\" path] break
  525.     }
  526.  
  527.     regsub {[\\]+$} $path "" path
  528.     return $drive$path
  529. }
  530.  
  531. # Win
  532. #
  533. # tixFSNormDir --
  534. #
  535. #    Normalizes a directory
  536. #
  537. proc tixFSNormDir {dir} {
  538.     if ![tixFSIsAbsPath $dir] {
  539.     error "\"$dir\" must be an absolute pathname"
  540.     }
  541.     if ![file isdir $dir] {
  542.     error "\"$dir\" is not a directory"
  543.     }
  544.     return [_tixNormalize $dir]
  545. }
  546.  
  547.  
  548. proc tixPanic {message} {
  549.     error $message
  550. }
  551.  
  552. # tixFSIsValid --
  553. #
  554. #    Checks whether a native pathname contains invalid characters.
  555. #
  556. proc tixFSIsValid {path} {
  557.     return 1
  558. }
  559.  
  560. # Win
  561. #
  562. #
  563. proc tixFSIsVPath {vpath} {
  564.     global tixPriv
  565.     if $tixPriv(isWin95) {
  566.     return [string match {xx\\xx\\[A-z]:*} $vpath]
  567.     } else {
  568.     return [string match {xx\\[A-z]:*} $vpath]
  569.     }
  570. }
  571.  
  572. # Win
  573. #
  574. # tixFSVPath --
  575. #
  576. #    Converts a normalized native pathname to its VPATH
  577. #
  578. proc tixFSVPath {path} {
  579.     global tixPriv
  580.  
  581.     tixAssert {
  582.     tixAssertNorm $path
  583.     }
  584.     return $tixPriv(WinPrefix)\\$path
  585. }
  586.  
  587. # tixFSPath --
  588. #
  589. #    Converts a vpath to a native pathname
  590. proc tixFSPath {vpath} {
  591.     global tixPriv
  592.     tixAssert {
  593.     tixAssertVPath $vpath
  594.     }
  595.     if $tixPriv(isWin95) {
  596.     set path [string range $vpath 6 end]
  597.     } else {
  598.     set path [string range $vpath 3 end]
  599.     }
  600.     regsub {:$} $path :\\ path
  601.  
  602.     return $path
  603. }
  604.  
  605. # tixFSDisplayName --
  606. #
  607. #    Returns the name of a normalized path which is usually displayed by
  608. #    the OS
  609. #
  610. proc tixFSDisplayName {normpath} {
  611.     tixAssert {
  612.     tixAssertNorm $normpath
  613.     }
  614.  
  615.     if [regexp {^[A-z]:$} $normpath] {
  616.     return $normpath\\
  617.     } else {
  618.     return $normpath
  619.     }
  620. }
  621.  
  622.  
  623. tixInitFileCmpt:Win 
  624.  
  625. }
  626.